home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / vbdrop / vbdrop.bas < prev    next >
BASIC Source File  |  1994-10-10  |  8KB  |  210 lines
  1. Option Explicit
  2.  
  3. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  4.  
  5. ' This file provide the APIs, constants, and functions to
  6. ' detect file drops on the registered form.
  7.  
  8. ' Using this code requires the use of the MSGBLAST.VBX, or some other
  9. ' callback control. (MicroHelp: MHCB200.VBX, Desaware: SBCHOOK.VBX) If
  10. ' you use some other callback control, you will need to make some minor
  11. ' adjustments to the code, because the parameter names in the events, and
  12. ' how you identify the messages you want to watch are different.
  13.  
  14. Type POINTSTRUCT                        ' API Point structure
  15.     PT_X               As Integer
  16.     PT_Y               As Integer
  17. End Type
  18.  
  19. Type MSGSTRUCT                          ' API Message structure
  20.     hWnd                As Integer
  21.     message             As Integer
  22.     wParam              As Integer
  23.     lParam              As Long
  24.     time                As Long
  25.     pt                  As POINTSTRUCT
  26. End Type
  27.  
  28. Global Const WM_SYSCOMMAND = &H112
  29. Global Const WM_DROPFILES = &H233
  30.  
  31. Declare Sub APIDragAcceptFiles Lib "Shell" Alias "DragAcceptFiles" (ByVal hWnd As Integer, ByVal fAccept As Integer)
  32. Declare Function APIDragQueryFile Lib "Shell" Alias "DragQueryFile" (ByVal hDrop As Integer, ByVal iFile As Integer, ByVal lpszFile As String, ByVal cb As Integer) As Integer
  33. Declare Sub APIDragFinish Lib "Shell" Alias "DragFinish" (ByVal hDrop As Integer)
  34. Declare Function APIPeekMessage Lib "User" Alias "PeekMessage" (lpMsg As MSGSTRUCT, ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, ByVal wMsgFilterMax As Integer, ByVal wRemoveMsg As Integer) As Integer
  35. Declare Function APIGetPrivateProfileString Lib "Kernel" Alias "GetPrivateProfileString" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
  36.  
  37. Global Const MF_BYCOMMAND = &H0
  38. Global Const MF_APPEND = &H100
  39. Global Const MF_SEPARATOR = &H800
  40. Global Const MF_ENABLED = &H0
  41. Global Const MF_STRING = &H0
  42.  
  43. Global Const MB_ICONINFORMATION = 64
  44.  
  45. Global Const IDM_ABOUT = 108
  46.  
  47. Declare Function APIGetSystemMenu Lib "User" Alias "GetSystemMenu" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
  48. Declare Function APIDeleteMenu Lib "User" Alias "DeleteMenu" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
  49. Declare Function APIAppendMenu Lib "User" Alias "AppendMenu" (ByVal hMenu As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpNewItem As Any) As Integer
  50.  
  51. Sub APP_About ()
  52.  
  53. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  54.     
  55.     Dim tTempStr            As String
  56.     Dim tCRLF               As String
  57.     
  58.     tCRLF = Chr$(13) & Chr$(10)
  59.     tTempStr = "Copyright ⌐ 1994 by Computer Technologies, Inc." & tCRLF & "All rights reserved."
  60.     tTempStr = tTempStr & tCRLF & tCRLF & "Version 1.0 - Released October 11, 1994."
  61.     tTempStr = tTempStr & tCRLF & tCRLF & "This demo program and all associated code is the property of Computer Technologies, Inc. It is provided as a service for the personal use of the members of the MS-BASIC forum on CompuServe, and other interested Visual Basic developers."
  62.     tTempStr = tTempStr & tCRLF & tCRLF & "Author:" & Chr$(9) & "Eric Brierley"
  63.     tTempStr = tTempStr & tCRLF & "CIS:" & Chr$(9) & "71163,2657"
  64.     tTempStr = tTempStr & tCRLF & "Phone:" & Chr$(9) & "1-704-634-1766"
  65.     MsgBox tTempStr, MB_ICONINFORMATION, "About Dust Bin"
  66.  
  67. End Sub
  68.  
  69. Sub APP_DeleteFiles (tFileNames As String)
  70.  
  71. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  72.  
  73.     Dim nResult             As Integer
  74.     Dim tOneFile            As String
  75.     Dim nLoopCtr            As Integer
  76.  
  77.     tOneFile = UT_GetStringToken(tFileNames, 1, ",")
  78.     
  79.     nLoopCtr = 1
  80.     Do While Len(tOneFile) > 0
  81.     nResult = UT_FileDelete(tOneFile)
  82.     nLoopCtr = nLoopCtr + 1
  83.     tOneFile = UT_GetStringToken(tFileNames, nLoopCtr, ",")
  84.     Loop
  85.  
  86. End Sub
  87.  
  88. Function UT_DropEnable (hHandle As Integer, ctlCallback As Control, nFirstMsg As Integer, bFlag As Integer) As Integer
  89.  
  90. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  91.  
  92. ' Calling Parameters:
  93. '   hHandle         Window handle (hWnd) of the form or control that is to
  94. '                   accept file drops
  95. '   ctlCallback     The callback control
  96. '   nFirstMsg       Pointer to first free message list entry
  97. '   bFlag           * Reserved for future use to enable or disable drag/drop
  98.  
  99. ' Returned:
  100. '   Pointer to the last message list entry used.
  101.  
  102.     Dim nMsgCounter         As Integer
  103.  
  104. ' Subclass the form if needed, then register the message we want to see.
  105. ' *** This code will need to be adjusted callback other than MSGBLAST.
  106.     nMsgCounter = nFirstMsg
  107.     If nMsgCounter = 0 Then ctlCallback.hWndTarget = hHandle
  108.     ctlCallback.MsgList(nMsgCounter) = WM_DROPFILES
  109.  
  110. ' Make the API call to tell the system that we will accept
  111. ' files dropped from other applications.
  112.     APIDragAcceptFiles hHandle, True
  113.  
  114. ' Set the return value to the last message pointer used
  115.     UT_DropEnable = nMsgCounter
  116.     
  117. End Function
  118.  
  119. Function UT_DropFileNames (MsgVal As Integer, wParam As Integer, lParam As Long) As String
  120.  
  121. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  122.  
  123. ' Calling Parameters:
  124. '   MsgVal          Windows message number associated with the file drop
  125. '   wParam          First message paramter contains drop message handle
  126.  
  127. ' Returned:
  128. '   A comma delimited list of the dropped file names
  129.  
  130.     Dim nFileCount          As Integer
  131.     Dim nLoopCtr            As Integer
  132.     Dim nResult             As Integer
  133.     Dim hDrop               As Integer
  134.     Dim tFileName           As String
  135.     Dim tTempStr            As String
  136.  
  137.     tFileName = ""
  138.     hDrop = wParam                      ' Handle of internal file structure
  139.     tTempStr = Space$(255)              ' Preallocate return storage
  140.  
  141. ' Get the number of file names dropped
  142.     nFileCount = APIDragQueryFile(hDrop, -1, tTempStr, 254)
  143.     
  144. ' For each file get the file name and add it to our working string. The
  145. ' API call return value is the number of characters in the file name.
  146.     For nLoopCtr = 0 To nFileCount - 1
  147.     tTempStr = Space$(255)              ' Preallocate return storage
  148.     nResult = APIDragQueryFile(hDrop, nLoopCtr, tTempStr, 254)
  149.     ' If this is not the first file name append a delimiter
  150.     If tFileName <> "" Then tFileName = tFileName & ","
  151.     tFileName = tFileName & Left$(tTempStr, nResult)
  152.     Next nLoopCtr
  153.     
  154.     APIDragFinish hDrop                 ' Release memory used for filenames
  155.  
  156.     UT_DropFileNames = tFileName        ' Pass back the file list
  157.  
  158. End Function
  159.  
  160. Function UT_FileDelete (tFileName As String) As Integer
  161.  
  162. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  163.  
  164.     Dim nError          As Integer
  165.  
  166.     On Error Resume Next
  167.     Kill tFileName
  168.     nError = Err
  169.     On Error GoTo 0
  170.  
  171.     If nError <> 0 Then
  172.     UT_FileDelete = nError
  173.       Else
  174.     UT_FileDelete = True
  175.     End If
  176.  
  177. End Function
  178.  
  179. Function UT_GetStringToken (tInString As String, nPosition As Integer, tDelimStr As String) As String
  180.  
  181. ' Copyright ⌐ 1994 by Computer Technologies, Inc. All rights reserved.
  182.  
  183.     Dim nHits               As Integer
  184.     Dim tTempStr            As String
  185.  
  186.     tTempStr = tInString
  187.  
  188.     nHits = 1
  189.     If nPosition < nHits Then
  190.     Exit Function
  191.     End If
  192.     Do While nHits <> nPosition And Len(tInString) > 1
  193.     If Mid$(tTempStr, 1, 1) = tDelimStr Then
  194.     nHits = nHits + 1
  195.     End If
  196.     tTempStr = Mid$(tTempStr, 2)
  197.     If tTempStr = "" Then
  198.     UT_GetStringToken = ""
  199.     Exit Function
  200.     End If
  201.     Loop
  202.     If InStr(1, tTempStr, tDelimStr) > 0 Then
  203.     UT_GetStringToken = Mid$(tTempStr, 1, InStr(1, tTempStr, tDelimStr) - 1)
  204.       Else
  205.     UT_GetStringToken = tTempStr
  206.     End If
  207.  
  208. End Function
  209.  
  210.